home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / win / tclWinFile.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  16.1 KB  |  656 lines  |  [TEXT/CWIE]
  1. /* 
  2.  * tclWinFile.c --
  3.  *
  4.  *      This file contains temporary wrappers around UNIX file handling
  5.  *      functions. These wrappers map the UNIX functions to Win32 HANDLE-style
  6.  *      files, which can be manipulated through the Win32 console redirection
  7.  *      interfaces.
  8.  *
  9.  * Copyright (c) 1995-1996 Sun Microsystems, Inc.
  10.  *
  11.  * See the file "license.terms" for information on usage and redistribution
  12.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13.  *
  14.  * SCCS: @(#) tclWinFile.c 1.44 97/08/05 11:45:34
  15.  */
  16.  
  17. #include "tclWinInt.h"
  18. #include <sys/stat.h>
  19. #include <shlobj.h>
  20.  
  21. /*
  22.  * The variable below caches the name of the current working directory
  23.  * in order to avoid repeated calls to getcwd.  The string is malloc-ed.
  24.  * NULL means the cache needs to be refreshed.
  25.  */
  26.  
  27. static char *currentDir =  NULL;
  28.  
  29.  
  30. /*
  31.  *----------------------------------------------------------------------
  32.  *
  33.  * Tcl_FindExecutable --
  34.  *
  35.  *    This procedure computes the absolute path name of the current
  36.  *    application, given its argv[0] value.
  37.  *
  38.  * Results:
  39.  *    None.
  40.  *
  41.  * Side effects:
  42.  *    The variable tclExecutableName gets filled in with the file
  43.  *    name for the application, if we figured it out.  If we couldn't
  44.  *    figure it out, Tcl_FindExecutable is set to NULL.
  45.  *
  46.  *----------------------------------------------------------------------
  47.  */
  48.  
  49. void
  50. Tcl_FindExecutable(argv0)
  51.     char *argv0;        /* The value of the application's argv[0]. */
  52. {
  53.     Tcl_DString buffer;
  54.     int length;
  55.  
  56.     Tcl_DStringInit(&buffer);
  57.  
  58.     if (tclExecutableName != NULL) {
  59.     ckfree(tclExecutableName);
  60.     tclExecutableName = NULL;
  61.     }
  62.  
  63.     /*
  64.      * Under Windows we ignore argv0, and return the path for the file used to
  65.      * create this process.
  66.      */
  67.  
  68.     Tcl_DStringSetLength(&buffer, MAX_PATH+1);
  69.     length = GetModuleFileName(NULL, Tcl_DStringValue(&buffer), MAX_PATH+1);
  70.     if (length > 0) {
  71.     tclExecutableName = (char *) ckalloc((unsigned) (length + 1));
  72.     strcpy(tclExecutableName, Tcl_DStringValue(&buffer));
  73.     }
  74.     Tcl_DStringFree(&buffer);
  75. }
  76.  
  77. /*
  78.  *----------------------------------------------------------------------
  79.  *
  80.  * TclMatchFiles --
  81.  *
  82.  *    This routine is used by the globbing code to search a
  83.  *    directory for all files which match a given pattern.
  84.  *
  85.  * Results: 
  86.  *    If the tail argument is NULL, then the matching files are
  87.  *    added to the interp->result.  Otherwise, TclDoGlob is called
  88.  *    recursively for each matching subdirectory.  The return value
  89.  *    is a standard Tcl result indicating whether an error occurred
  90.  *    in globbing.
  91.  *
  92.  * Side effects:
  93.  *    None.
  94.  *
  95.  *---------------------------------------------------------------------- */
  96.  
  97. int
  98. TclMatchFiles(interp, separators, dirPtr, pattern, tail)
  99.     Tcl_Interp *interp;        /* Interpreter to receive results. */
  100.     char *separators;        /* Directory separators to pass to TclDoGlob. */
  101.     Tcl_DString *dirPtr;    /* Contains path to directory to search. */
  102.     char *pattern;        /* Pattern to match against. */
  103.     char *tail;            /* Pointer to end of pattern.  Tail must
  104.                  * point to a location in pattern. */
  105. {
  106.     char drivePattern[4] = "?:\\";
  107.     char *newPattern, *p, *dir, *root, c;
  108.     int length, matchDotFiles;
  109.     int result = TCL_OK;
  110.     int baseLength = Tcl_DStringLength(dirPtr);
  111.     Tcl_DString buffer;
  112.     DWORD atts, volFlags;
  113.     HANDLE handle;
  114.     WIN32_FIND_DATA data;
  115.     BOOL found;
  116.  
  117.     /*
  118.      * Convert the path to normalized form since some interfaces only
  119.      * accept backslashes.  Also, ensure that the directory ends with a
  120.      * separator character.
  121.      */
  122.  
  123.     Tcl_DStringInit(&buffer);
  124.     if (baseLength == 0) {
  125.     Tcl_DStringAppend(&buffer, ".", 1);
  126.     } else {
  127.     Tcl_DStringAppend(&buffer, Tcl_DStringValue(dirPtr),
  128.         Tcl_DStringLength(dirPtr));
  129.     }
  130.     for (p = Tcl_DStringValue(&buffer); *p != '\0'; p++) {
  131.     if (*p == '/') {
  132.         *p = '\\';
  133.     }
  134.     }
  135.     p--;
  136.     if (*p != '\\' && *p != ':') {
  137.     Tcl_DStringAppend(&buffer, "\\", 1);
  138.     }
  139.     dir = Tcl_DStringValue(&buffer);
  140.     
  141.     /*
  142.      * First verify that the specified path is actually a directory.
  143.      */
  144.  
  145.     atts = GetFileAttributes(dir);
  146.     if ((atts == 0xFFFFFFFF) || ((atts & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
  147.     Tcl_DStringFree(&buffer);
  148.     return TCL_OK;
  149.     }
  150.  
  151.     /*
  152.      * Next check the volume information for the directory to see whether
  153.      * comparisons should be case sensitive or not.  If the root is null, then
  154.      * we use the root of the current directory.  If the root is just a drive
  155.      * specifier, we use the root directory of the given drive.
  156.      */
  157.  
  158.     switch (Tcl_GetPathType(dir)) {
  159.     case TCL_PATH_RELATIVE:
  160.         found = GetVolumeInformation(NULL, NULL, 0, NULL,
  161.             NULL, &volFlags, NULL, 0);
  162.         break;
  163.     case TCL_PATH_VOLUME_RELATIVE:
  164.         if (*dir == '\\') {
  165.         root = NULL;
  166.         } else {
  167.         root = drivePattern;
  168.         *root = *dir;
  169.         }
  170.         found = GetVolumeInformation(root, NULL, 0, NULL,
  171.             NULL, &volFlags, NULL, 0);
  172.         break;
  173.     case TCL_PATH_ABSOLUTE:
  174.         if (dir[1] == ':') {
  175.         root = drivePattern;
  176.         *root = *dir;
  177.         found = GetVolumeInformation(root, NULL, 0, NULL,
  178.             NULL, &volFlags, NULL, 0);
  179.         } else if (dir[1] == '\\') {
  180.         p = strchr(dir+2, '\\');
  181.         p = strchr(p+1, '\\');
  182.         p++;
  183.         c = *p;
  184.         *p = 0;
  185.         found = GetVolumeInformation(dir, NULL, 0, NULL,
  186.             NULL, &volFlags, NULL, 0);
  187.         *p = c;
  188.         }
  189.         break;
  190.     }
  191.  
  192.     if (!found) {
  193.     Tcl_DStringFree(&buffer);
  194.     TclWinConvertError(GetLastError());
  195.     Tcl_ResetResult(interp);
  196.     Tcl_AppendResult(interp, "couldn't read volume information for \"",
  197.         dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL);
  198.     return TCL_ERROR;
  199.     }
  200.     
  201.     /*
  202.      * If the volume is not case sensitive, then we need to convert the pattern
  203.      * to lower case.
  204.      */
  205.  
  206.     length = tail - pattern;
  207.     newPattern = ckalloc(length+1);
  208.     if (volFlags & FS_CASE_SENSITIVE) {
  209.     strncpy(newPattern, pattern, length);
  210.     newPattern[length] = '\0';
  211.     } else {
  212.     char *src, *dest;
  213.     for (src = pattern, dest = newPattern; src < tail; src++, dest++) {
  214.         *dest = (char) tolower(*src);
  215.     }
  216.     *dest = '\0';
  217.     }
  218.     
  219.     /*
  220.      * We need to check all files in the directory, so append a *.*
  221.      * to the path. 
  222.      */
  223.  
  224.  
  225.     dir = Tcl_DStringAppend(&buffer, "*.*", 3);
  226.  
  227.     /*
  228.      * Now open the directory for reading and iterate over the contents.
  229.      */
  230.  
  231.     handle = FindFirstFile(dir, &data);
  232.     Tcl_DStringFree(&buffer);
  233.  
  234.     if (handle == INVALID_HANDLE_VALUE) {
  235.     TclWinConvertError(GetLastError());
  236.     Tcl_ResetResult(interp);
  237.     Tcl_AppendResult(interp, "couldn't read directory \"",
  238.         dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL);
  239.     ckfree(newPattern);
  240.     return TCL_ERROR;
  241.     }
  242.  
  243.     /*
  244.      * Clean up the tail pointer.  Leave the tail pointing to the 
  245.      * first character after the path separator or NULL. 
  246.      */
  247.  
  248.     if (*tail == '\\') {
  249.     tail++;
  250.     }
  251.     if (*tail == '\0') {
  252.     tail = NULL;
  253.     } else {
  254.     tail++;
  255.     }
  256.  
  257.     /*
  258.      * Check to see if the pattern needs to compare with dot files.
  259.      */
  260.  
  261.     if ((newPattern[0] == '.')
  262.         || ((pattern[0] == '\\') && (pattern[1] == '.'))) {
  263.         matchDotFiles = 1;
  264.     } else {
  265.         matchDotFiles = 0;
  266.     }
  267.  
  268.     /*
  269.      * Now iterate over all of the files in the directory.
  270.      */
  271.  
  272.     Tcl_DStringInit(&buffer);
  273.     for (found = 1; found; found = FindNextFile(handle, &data)) {
  274.     char *matchResult;
  275.  
  276.     /*
  277.      * Ignore hidden files.
  278.      */
  279.  
  280.     if (!matchDotFiles && (data.cFileName[0] == '.')) {
  281.         continue;
  282.     }
  283.  
  284.     /*
  285.      * Check to see if the file matches the pattern.  If the volume is not
  286.      * case sensitive, we need to convert the file name to lower case.  If
  287.      * the volume also doesn't preserve case, then we return the lower case
  288.      * form of the name, otherwise we return the system form.
  289.       */
  290.  
  291.     matchResult = NULL;
  292.     if (!(volFlags & FS_CASE_SENSITIVE)) {
  293.         Tcl_DStringSetLength(&buffer, 0);
  294.         Tcl_DStringAppend(&buffer, data.cFileName, -1);
  295.         for (p = buffer.string; *p != '\0'; p++) {
  296.         *p = (char) tolower(*p);
  297.         }
  298.         if (Tcl_StringMatch(buffer.string, newPattern)) {
  299.         if (volFlags & FS_CASE_IS_PRESERVED) {
  300.             matchResult = data.cFileName;
  301.         } else {
  302.             matchResult = buffer.string;
  303.         }    
  304.         }
  305.     } else {
  306.         if (Tcl_StringMatch(data.cFileName, newPattern)) {
  307.         matchResult = data.cFileName;
  308.         }
  309.     }
  310.  
  311.     if (matchResult == NULL) {
  312.         continue;
  313.     }
  314.  
  315.     /*
  316.      * If the file matches, then we need to process the remainder of the
  317.      * path.  If there are more characters to process, then ensure matching
  318.      * files are directories and call TclDoGlob. Otherwise, just add the
  319.      * file to the result.
  320.      */
  321.  
  322.     Tcl_DStringSetLength(dirPtr, baseLength);
  323.     Tcl_DStringAppend(dirPtr, matchResult, -1);
  324.     if (tail == NULL) {
  325.         Tcl_AppendElement(interp, dirPtr->string);
  326.     } else {
  327.         atts = GetFileAttributes(dirPtr->string);
  328.         if (atts & FILE_ATTRIBUTE_DIRECTORY) {
  329.         Tcl_DStringAppend(dirPtr, "/", 1);
  330.         result = TclDoGlob(interp, separators, dirPtr, tail);
  331.         if (result != TCL_OK) {
  332.             break;
  333.         }
  334.         }
  335.     }
  336.     }
  337.  
  338.     Tcl_DStringFree(&buffer);
  339.     FindClose(handle);
  340.     ckfree(newPattern);
  341.     return result;
  342. }
  343.  
  344. /*
  345.  *----------------------------------------------------------------------
  346.  *
  347.  * TclChdir --
  348.  *
  349.  *    Change the current working directory.
  350.  *
  351.  * Results:
  352.  *    The result is a standard Tcl result.  If an error occurs and 
  353.  *    interp isn't NULL, an error message is left in interp->result.
  354.  *
  355.  * Side effects:
  356.  *    The working directory for this application is changed.  Also
  357.  *    the cache maintained used by TclGetCwd is deallocated and
  358.  *    set to NULL.
  359.  *
  360.  *----------------------------------------------------------------------
  361.  */
  362.  
  363. int
  364. TclChdir(interp, dirName)
  365.     Tcl_Interp *interp;        /* If non NULL, used for error reporting. */
  366.     char *dirName;             /* Path to new working directory. */
  367. {
  368.     if (currentDir != NULL) {
  369.     ckfree(currentDir);
  370.     currentDir = NULL;
  371.     }
  372.     if (!SetCurrentDirectory(dirName)) {
  373.     TclWinConvertError(GetLastError());
  374.     if (interp != NULL) {
  375.         Tcl_AppendResult(interp, "couldn't change working directory to \"",
  376.             dirName, "\": ", Tcl_PosixError(interp), (char *) NULL);
  377.     }
  378.     return TCL_ERROR;
  379.     }
  380.     return TCL_OK;
  381. }
  382.  
  383. /*
  384.  *----------------------------------------------------------------------
  385.  *
  386.  * TclGetCwd --
  387.  *
  388.  *    Return the path name of the current working directory.
  389.  *
  390.  * Results:
  391.  *    The result is the full path name of the current working
  392.  *    directory, or NULL if an error occurred while figuring it
  393.  *    out.  If an error occurs and interp isn't NULL, an error
  394.  *    message is left in interp->result.
  395.  *
  396.  * Side effects:
  397.  *    The path name is cached to avoid having to recompute it
  398.  *    on future calls;  if it is already cached, the cached
  399.  *    value is returned.
  400.  *
  401.  *----------------------------------------------------------------------
  402.  */
  403.  
  404. char *
  405. TclGetCwd(interp)
  406.     Tcl_Interp *interp;        /* If non NULL, used for error reporting. */
  407. {
  408.     static char buffer[MAXPATHLEN+1];
  409.     char *bufPtr, *p;
  410.  
  411.     if (currentDir == NULL) {
  412.     if (GetCurrentDirectory(MAXPATHLEN+1, buffer) == 0) {
  413.         TclWinConvertError(GetLastError());
  414.         if (interp != NULL) {
  415.         if (errno == ERANGE) {
  416.             Tcl_SetResult(interp,
  417.                 "working directory name is too long",
  418.                 TCL_STATIC);
  419.         } else {
  420.             Tcl_AppendResult(interp,
  421.                 "error getting working directory name: ",
  422.                 Tcl_PosixError(interp), (char *) NULL);
  423.         }
  424.         }
  425.         return NULL;
  426.     }
  427.     /*
  428.      * Watch for the wierd Windows '95 c:\\UNC syntax.
  429.      */
  430.  
  431.     if (buffer[0] != '\0' && buffer[1] == ':' && buffer[2] == '\\'
  432.         && buffer[3] == '\\') {
  433.         bufPtr = &buffer[2];
  434.     } else {
  435.         bufPtr = buffer;
  436.     }
  437.  
  438.     /*
  439.      * Convert to forward slashes for easier use in scripts.
  440.      */
  441.  
  442.     for (p = bufPtr; *p != '\0'; p++) {
  443.         if (*p == '\\') {
  444.         *p = '/';
  445.         }
  446.     }
  447.     }
  448.     return bufPtr;
  449. }
  450.  
  451. #if 0
  452. /*
  453.  *-------------------------------------------------------------------------
  454.  *
  455.  * TclWinResolveShortcut --
  456.  *
  457.  *    Resolve a potential Windows shortcut to get the actual file or 
  458.  *    directory in question.  
  459.  *
  460.  * Results:
  461.  *    Returns 1 if the shortcut could be resolved, or 0 if there was
  462.  *    an error or if the filename was not a shortcut.
  463.  *    If bufferPtr did hold the name of a shortcut, it is modified to
  464.  *    hold the resolved target of the shortcut instead.
  465.  *
  466.  * Side effects:
  467.  *    Loads and unloads OLE package to determine if filename refers to
  468.  *    a shortcut.
  469.  *
  470.  *-------------------------------------------------------------------------
  471.  */
  472.  
  473. int
  474. TclWinResolveShortcut(bufferPtr)
  475.     Tcl_DString *bufferPtr;    /* Holds name of file to resolve.  On 
  476.                  * return, holds resolved file name. */
  477. {
  478.     HRESULT hres; 
  479.     IShellLink *psl; 
  480.     IPersistFile *ppf; 
  481.     WIN32_FIND_DATA wfd; 
  482.     WCHAR wpath[MAX_PATH];
  483.     char *path, *ext;
  484.     char realFileName[MAX_PATH];
  485.  
  486.     /*
  487.      * Windows system calls do not automatically resolve
  488.      * shortcuts like UNIX automatically will with symbolic links.
  489.      */
  490.  
  491.     path = Tcl_DStringValue(bufferPtr);
  492.     ext = strrchr(path, '.');
  493.     if ((ext == NULL) || (stricmp(ext, ".lnk") != 0)) {
  494.     return 0;
  495.     }
  496.  
  497.     CoInitialize(NULL);
  498.     path = Tcl_DStringValue(bufferPtr);
  499.     realFileName[0] = '\0';
  500.     hres = CoCreateInstance(&CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER, 
  501.         &IID_IShellLink, &psl); 
  502.     if (SUCCEEDED(hres)) { 
  503.     hres = psl->lpVtbl->QueryInterface(psl, &IID_IPersistFile, &ppf);
  504.     if (SUCCEEDED(hres)) { 
  505.         MultiByteToWideChar(CP_ACP, 0, path, -1, wpath, sizeof(wpath));
  506.         hres = ppf->lpVtbl->Load(ppf, wpath, STGM_READ); 
  507.         if (SUCCEEDED(hres)) {
  508.         hres = psl->lpVtbl->Resolve(psl, NULL, 
  509.             SLR_ANY_MATCH | SLR_NO_UI); 
  510.         if (SUCCEEDED(hres)) { 
  511.             hres = psl->lpVtbl->GetPath(psl, realFileName, MAX_PATH, 
  512.                 &wfd, 0);
  513.         } 
  514.         } 
  515.         ppf->lpVtbl->Release(ppf); 
  516.     } 
  517.     psl->lpVtbl->Release(psl); 
  518.     } 
  519.     CoUninitialize();
  520.  
  521.     if (realFileName[0] != '\0') {
  522.     Tcl_DStringSetLength(bufferPtr, 0);
  523.     Tcl_DStringAppend(bufferPtr, realFileName, -1);
  524.     return 1;
  525.     }
  526.     return 0;
  527. }
  528. #endif
  529.  
  530. /*
  531.  *----------------------------------------------------------------------
  532.  *
  533.  * TclWinStat, TclWinLstat --
  534.  *
  535.  *    These functions replace the library versions of stat and lstat.
  536.  *
  537.  *    The stat and lstat functions provided by some Windows compilers 
  538.  *    are incomplete.  Ideally, a complete rewrite of stat would go
  539.  *    here; now, the only fix is that stat("c:") used to return an
  540.  *    error instead infor for current dir on specified drive.
  541.  *
  542.  * Results:
  543.  *    See stat documentation.
  544.  *
  545.  * Side effects:
  546.  *    See stat documentation.
  547.  *
  548.  *----------------------------------------------------------------------
  549.  */
  550.  
  551. int
  552. TclWinStat(path, buf)
  553.     CONST char *path;        /* Path of file to stat (in current CP). */
  554.     struct stat *buf;        /* Filled with results of stat call. */
  555. {
  556.     char name[4];
  557.     int result;
  558.  
  559.     if ((strlen(path) == 2) && (path[1] == ':')) {
  560.     strcpy(name, path);
  561.     name[2] = '.';
  562.     name[3] = '\0';
  563.     path = name;
  564.     }
  565.  
  566. #undef stat
  567.  
  568.     result = stat(path, buf);
  569.  
  570. #ifndef _MSC_VER
  571.  
  572.     /*
  573.      * Borland's stat doesn't take into account localtime.
  574.      */
  575.  
  576.     if ((result == 0) && (buf->st_mtime != 0)) {
  577.     TIME_ZONE_INFORMATION tz;
  578.     int time, bias;
  579.  
  580.     time = GetTimeZoneInformation(&tz);
  581.     bias = tz.Bias;
  582.     if (time == TIME_ZONE_ID_DAYLIGHT) {
  583.         bias += tz.DaylightBias;
  584.     }
  585.     bias *= 60;
  586.     buf->st_atime -= bias;
  587.     buf->st_ctime -= bias;
  588.     buf->st_mtime -= bias;
  589.     }
  590.  
  591. #endif
  592.  
  593.     return result;
  594. }
  595.  
  596. /*
  597.  *---------------------------------------------------------------------------
  598.  *
  599.  * TclWinAccess --
  600.  *
  601.  *    This function replaces the library version of access.
  602.  *
  603.  *    The library version of access returns that all files have execute
  604.  *    permission.
  605.  *
  606.  * Results:
  607.  *    See access documentation.
  608.  *
  609.  * Side effects:
  610.  *    See access documentation.
  611.  *
  612.  *---------------------------------------------------------------------------
  613.  */
  614.  
  615. int
  616. TclWinAccess(
  617.     CONST char *path,        /* Path of file to access (in current CP). */
  618.     int mode)            /* Permission setting. */
  619. {
  620.     int result;
  621.     CONST char *p;
  622.  
  623. #undef access
  624.  
  625.     result = access(path, mode);
  626.  
  627.     if (result == 0) {
  628.     if (mode & 1) {
  629.         if (GetFileAttributes(path) & FILE_ATTRIBUTE_DIRECTORY) {
  630.         /*
  631.          * Directories are always executable. 
  632.          */
  633.  
  634.         return 0;
  635.         }
  636.         p = strrchr(path, '.');
  637.         if (p != NULL) {
  638.         p++;
  639.         if ((stricmp(p, "exe") == 0)
  640.             || (stricmp(p, "com") == 0)
  641.             || (stricmp(p, "bat") == 0)) {
  642.             /*
  643.              * File that ends with .exe, .com, or .bat is executable.
  644.              */
  645.  
  646.             return 0;
  647.         }
  648.         }
  649.         errno = EACCES;
  650.         return -1;
  651.     }
  652.     }
  653.     return result;
  654. }
  655.  
  656.